home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 501-525 / disk_503 / pcq / pcq12asc.lzh / Source / Expr.p < prev    next >
Text File  |  1991-04-19  |  28KB  |  1,005 lines
  1. External;
  2.  
  3. {$I "Pascal.i"}
  4.  
  5.     Function TypeCheck(l, r : TypePtr) : Boolean;
  6.         External;
  7.     Function TypeCmp(l, r : TypePtr) : Boolean;
  8.         External;
  9.     Procedure ReadChar;
  10.         External;
  11.     Procedure NextSymbol;
  12.         External;
  13.     Procedure Error(s : string);
  14.         External;
  15.     Procedure Abort;
  16.         External;
  17.     Function Match(s : Symbols): Boolean;
  18.         External;
  19.     Function FindID(s : string) : IDPtr;
  20.         External;
  21.     Function FindField(s : string; TP : TypePtr): IDPtr;
  22.         External;
  23.     Function FindWithField(S : String) : IDPtr;
  24.         External;
  25.     Procedure Mismatch;
  26.         External;
  27.     Procedure NeedRightParent;
  28.         External;
  29.     Procedure NeedLeftParent;
  30.         External;
  31.     Procedure NeedNumber;
  32.         External;
  33.     Function NumberType(l : TypePtr) : Boolean;
  34.         External;
  35.     Function BaseType(b : TypePtr): TypePtr;
  36.         External;
  37.     Function SimpleType(t : TypePtr) : Boolean;
  38.         External;
  39.     Function EnterStandard(    st_Name : String;
  40.                 st_Object : IDObject;
  41.                 st_Type : TypePtr;
  42.                 st_Storage : IDStorage;
  43.                 st_Offset : Integer) : IDPtr;
  44.         External;
  45.  
  46. Function GetExpressionNode : ExprPtr;
  47. var
  48.     Expr : ExprPtr;
  49. begin
  50.     if NextFreeExprNode <= MaxExprNodes then begin
  51.     Expr := Adr(ExpressionNodeStore[NextFreeExprNode]);
  52.     Inc(NextFreeExprNode);
  53.     GetExpressionNode := Expr;
  54.     end else begin
  55.     New(Expr);
  56.     GetExpressionNode := Expr;
  57.     end;
  58. end;
  59.  
  60. Procedure FreeExpressionNode(Expr : ExprPtr);
  61. begin
  62.     Expr^.Used := False;
  63. end;
  64.  
  65. Function MakeNode(Op : Symbols; L, R : ExprPtr; TP : TypePtr; Val : Integer) : ExprPtr;
  66. var
  67.     Expr : ExprPtr;
  68. begin
  69.     Expr := GetExpressionNode;
  70.     with Expr^ do begin
  71.     Kind    := Op;
  72.     Next    := Nil;
  73.     Left    := L;
  74.     Right    := R;
  75.     EType    := BaseType(TP);
  76.     Value    := Val;
  77.     end;
  78.     MakeNode := Expr;
  79. end;
  80.  
  81. Function MakeBinary(Op : Symbols; L, R : ExprPtr; TP : TypePtr) : ExprPtr;
  82. begin
  83.     MakeBinary := MakeNode(Op,L,R,TP,0);
  84. end;
  85.  
  86. Function MakeCommutativeBinary(Op : Symbols; L, R : ExprPtr; TP : TypePtr) : ExprPtr;
  87. begin
  88.     if L^.Kind = Const1 then
  89.     MakeCommutativeBinary := MakeNode(Op, L, R, TP, 0);
  90.     if R^.Kind = Const1 then
  91.         MakeCommutativeBinary := MakeNode(Op, R, L, TP, 0);
  92.     if (L^.Kind = Var1) or (L^.Kind = Period1) then
  93.     MakeCommutativeBinary := MakeNode(Op, L, R, TP, 0);
  94.     MakeCommutativeBinary := MakeNode(Op, R, L, TP, 0);
  95. end;
  96.  
  97. Function MakeConstant(Val : Integer; TP : TypePtr) : ExprPtr;
  98. begin
  99.     if (TP = StringType) or (TP^.Object = ob_array) then
  100.     MakeConstant := MakeNode(Quote1, Nil, Nil, TP, Val)
  101.     else
  102.     MakeConstant := MakeNode(Const1, Nil, Nil, TP, Val);
  103. end;
  104.  
  105. Function MakeVariable(ID : IDPtr; TP : TypePtr) : ExprPtr;
  106. begin
  107.     MakeVariable := MakeNode(Var1, Nil, Nil, TP, Integer(ID));
  108. end;
  109.  
  110. Function CommonType(type1, type2 : TypePtr) : TypePtr;
  111. begin
  112.     Type1 := BaseType(Type1);
  113.     Type2 := BaseType(Type2);
  114.     if (Type1 = BadType) or (Type2 = BadType) then
  115.         CommonType := BadType;
  116.     if (Type1 = RealType) or (Type2 = RealType) then
  117.         CommonType := RealType;
  118.     if (Type1 = IntType) or (Type2 = IntType) then
  119.         CommonType := IntType;
  120.     if (Type1 = ShortType) or (Type2 = ShortType) then
  121.     CommonType := ShortType;
  122.     if (Type1 = ByteType) or (Type2 = ByteType) then
  123.     CommonType := ByteType;
  124.     CommonType := Type1; { What else is there? }
  125. end;
  126.  
  127. Function PromoteTypeA(Expr : ExprPtr; TP : TypePtr) : ExprPtr;
  128. var
  129.     Common : TypePtr;
  130. begin
  131.     Common := CommonType(Expr^.EType, TP);
  132.     if (Common = Expr^.EType) or (Common = BadType) then
  133.         PromoteTypeA := Expr;
  134.  
  135.     if Common = RealType then
  136.     PromoteTypeA := MakeBinary(int2real, PromoteTypeA(Expr, IntType),
  137.                 Nil, RealType)
  138.     else if Common = IntType then
  139.     PromoteTypeA := MakeBinary(short2long, PromoteTypeA(Expr, ShortType),
  140.                     Nil, IntType)
  141.     else if Common = ShortType then
  142.     PromoteTypeA := MakeBinary(byte2short, Expr, Nil, ShortType)
  143.     else
  144.     PromoteTypeA := Expr;
  145. end;
  146.  
  147. Procedure CheckNumeric(Expr : ExprPtr);
  148. begin
  149.     if not NumberType(Expr^.EType) then begin
  150.     NeedNumber;
  151.         Expr^.EType := BadType;
  152.     end;
  153. end;
  154.  
  155. Procedure CheckType(Left, Right : ExprPtr);
  156. begin
  157.     if not TypeCheck(Left^.EType, Right^.EType) then begin
  158.     MisMatch;
  159.     Left^.EType := BadType;
  160.     Right^.EType := BadType;
  161.     end;
  162. end;
  163.  
  164. Procedure CheckOrdinal(Expr : ExprPtr);
  165. begin
  166.     if Expr^.EType^.Object <> ob_ordinal then begin
  167.     Expr^.EType := BadType;
  168.     Error("Expecting an Ordinal Expression");
  169.     end;
  170. end;
  171.  
  172. Function AutoInt(Expr : ExprPtr) : ExprPtr;
  173. begin
  174.     with Expr^ do begin
  175.     if EType = RealType then
  176.         AutoInt := MakeNode(real2int,Expr,Nil,IntType,0)
  177.     else
  178.         AutoInt := Expr;
  179.     end;
  180. end;
  181.  
  182. Function ExpressionTree : ExprPtr;
  183.     Forward;
  184. Function Factor : ExprPtr;
  185.     Forward;
  186. Function GetReference : ExprPtr;
  187.     Forward;
  188.  
  189. Function BuildError(ErrorMsg : String) : ExprPtr;
  190. begin
  191.     Error(ErrorMsg);
  192.     BuildError := MakeNode(unknown1, Nil, Nil, BadType, 0);
  193. end;
  194.  
  195. Function OrdinalError : ExprPtr;
  196. begin
  197.     OrdinalError := BuildError("Expecting an ordinal expression");
  198. end;
  199.  
  200. Function NumericError : ExprPtr;
  201. begin
  202.     NumericError := BuildError("Expecting a numeric expression");
  203. end;
  204.  
  205. Procedure IncLitPtrA;
  206. begin
  207.     if LitPtr >= LiteralSize then begin
  208.     Writeln('Too much literal data');
  209.     Abort;
  210.     end else
  211.     Inc(LitPtr);
  212. end;
  213.  
  214. Function ReadLitA(Quote : Char) : TypePtr;
  215.  
  216. {
  217.     This routine reads a literal array of char into the literal
  218. array.
  219. }
  220. var
  221.     Length : Short;
  222. begin
  223.     Length := 1;
  224.     while (currentchar <> Quote) and (currentchar <> chr(10)) do begin
  225.     if CurrentChar = '\\' then begin
  226.         ReadChar;
  227.         if CurrentChar = Chr(10) then
  228.         Error("Missing closing quote");
  229.         case CurrentChar of
  230.           'n' : Litq[LitPtr] := Chr(10);
  231.           't' : Litq[LitPtr] := Chr(9);
  232.           '0' : Litq[LitPtr] := Chr(0);
  233.           'b' : Litq[LitPtr] := Chr(8);
  234.           'e' : Litq[LitPtr] := Chr(27);
  235.           'c' : Litq[LitPtr] := Chr($9B);
  236.           'a' : Litq[LitPtr] := Chr(7);
  237.           'f' : Litq[LitPtr] := Chr(12);
  238.           'r' : Litq[LitPtr] := Chr(13);
  239.           'v' : Litq[LitPtr] := Chr(11);
  240.         else
  241.         Litq[LitPtr] := CurrentChar;
  242.         end;
  243.     end else
  244.         Litq[LitPtr] := CurrentChar;
  245.     if CurrentChar <> Chr(10) then begin
  246.         ReadChar;
  247.         if currentchar = chr(10) then
  248.         error("Missing closing quote");
  249.     end;
  250.     Inc(Length);
  251.     IncLitPtrA;
  252.     end;
  253.     ReadChar;
  254.     NextSymbol;
  255.     if Quote = '"' then begin
  256.     LitQ[LitPtr] := Chr(0);
  257.     IncLitPtrA;
  258.     ReadLitA := StringType;
  259.     end else begin
  260.     LiteralType^.Upper := Length - 1;
  261.     ReadLitA := LiteralType;
  262.     end;
  263. end;
  264.  
  265. Function GetStandardFunction(ID : IDPtr) : ExprPtr;
  266. var
  267.     Expr : ExprPtr;
  268.     Expr2 : ExprPtr;
  269.     TypeID : IDPtr;
  270. begin
  271.     NeedLeftParent;
  272.     if (ID^.Offset < 15) or (ID^.Offset > 16) then
  273.     Expr := ExpressionTree;
  274.  
  275.     case ID^.Offset of
  276. {Ord} 1 : begin
  277.         if Expr^.EType^.Object = ob_ordinal then begin
  278.         case Expr^.EType^.Size of
  279.           1 : Expr := MakeNode(stanfunc1, Expr, Nil, ByteType, 1);
  280.           2 : Expr := MakeNode(stanfunc1, Expr, Nil, ShortType, 1);
  281.           4 : Expr := MakeNode(stanfunc1, Expr, Nil, IntType, 1);
  282.         end;
  283.         end else
  284.         Expr := OrdinalError;
  285.       end;
  286. {Chr} 2 : if NumberType(Expr^.EType) then
  287.           Expr := MakeNode(stanfunc1, AutoInt(Expr), Nil, CharType, 2)
  288.       else
  289.           Expr := NumericError;
  290. {Odd} 3 : if NumberType(Expr^.EType) then
  291.           Expr := MakeNode(stanfunc1, AutoInt(Expr), Nil, BoolType, 3)
  292.       else
  293.           Expr := NumericError;
  294. {Abs}  4 : if NumberType(Expr^.EType) then
  295.           Expr := MakeNode(stanfunc1, Expr, Nil, Expr^.EType, ID^.Offset)
  296.       else
  297.           Expr := NumericError;
  298. {Succ} 5,
  299. {Pred} 6 : if Expr^.Etype^.Object = ob_ordinal then
  300.            Expr := MakeNode(stanfunc1, Expr, Nil, Expr^.EType, ID^.Offset)
  301.        else
  302.            Expr := OrdinalError;
  303. {ReOpen} 7,
  304. {Open}   8 :
  305.         begin
  306.         if TypeCheck(StringType,Expr^.EType) then begin
  307.             if not Match(comma1) then
  308.             Error("Expecting a comma");
  309.             Expr2 := GetReference;
  310.             if Expr2^.EType^.Object = ob_file then
  311.             Expr := MakeNode(stanfunc1, Expr2, Expr, BoolType, ID^.Offset)
  312.             else
  313.             Expr := BuildError("Expecting a file type");
  314.             if Match(Comma1) then begin
  315.             Expr2 := ExpressionTree;
  316.             if not TypeCheck(Expr2^.EType,IntType) then
  317.                 Expr2 := BuildError("Mismatched Types");
  318.             end else
  319.             Expr2 := MakeNode(Const1,Nil,Nil,IntType,128);
  320.             Expr^.Left^.Next := Expr2;
  321.         end else
  322.             Expr := BuildError("Expecting a string expression");
  323.         end;
  324. {EOF} 9 : if Expr^.EType^.Object = ob_file then
  325.           Expr := MakeNode(stanfunc1, Expr, Nil, BoolType, 9)
  326.       else
  327.           Expr := BuildError("Expecting a file variable");
  328. {Trunc} 10,
  329. {Round} 11 :
  330.         if TypeCmp(Expr^.EType,RealType) then
  331.         Expr := MakeNode(stanfunc1, Expr, Nil, IntType, ID^.Offset)
  332.         else
  333.         Expr := BuildError("Expecting a floating point expression");
  334. {Float} 12 : if NumberType(Expr^.EType) and (Expr^.EType^.Object = ob_ordinal) then
  335.         Expr := MakeNode(stanfunc1, PromoteTypeA(Expr,IntType),
  336.                     Nil, RealType, 12)
  337.          else
  338.         Expr := BuildError("Expecting an ordinal number");
  339. {Floor} 13,
  340. {Ceil}  14 : if TypeCmp(Expr^.EType, RealType) then
  341.         Expr := MakeNode(stanfunc1, Expr, Nil, RealType, ID^.Offset)
  342.          else
  343.         Expr := BuildError("Expecting a floating point expression");
  344. {SizeOf}
  345.      15 : begin
  346.          if CurrSym = Ident1 then begin
  347.         TypeID := FindId(SymText);
  348.         if TypeID <> Nil then begin
  349.             if TypeID^.Object = obtype then
  350.             Expr := MakeNode(Const1, Nil, Nil, IntType, TypeID^.VType^.Size)
  351.             else
  352.             Expr := BuildError("Expecting a type");
  353.         end else
  354.             Expr := BuildError("Unknown ID");
  355.         end else
  356.         Expr := BuildError("Expecting an ID");
  357.         NextSymbol;
  358.     end;
  359. {Adr}
  360.      16 : Expr := MakeNode(at1, GetReference, Nil, AddressType, 0);
  361. {Bit}
  362.      17 : if NumberType(Expr^.EType) and (Expr^.EType^.Object = ob_ordinal) then
  363.           Expr := MakeNode(shl1, MakeConstant(1,IntType), Expr, IntType, 17)
  364.       else
  365.           Expr := BuildError("Expecting an ordinal number");
  366. {Sqr}18 : if NumberType(Expr^.EType) then
  367.           Expr := MakeNode(stanfunc1, Expr, Nil, Expr^.EType, 18)
  368.       else
  369.           Expr := NumericError;
  370.      19..25 : { Sin, Cos, Sqrt, Tan, ArcTan, Ln, Exp }
  371.         if NumberType(Expr^.EType) then
  372.         Expr := MakeNode(stanfunc1, PromoteTypeA(Expr,RealType),
  373.                         Nil, RealType, ID^.Offset)
  374.         else
  375.         Expr := NumericError;
  376.     end;
  377.     NeedRightParent;
  378.     GetStandardFunction := Expr;
  379. end;
  380.  
  381. Function ReadParameters(ID : IDPtr) : ExprPtr;
  382. var
  383.     CurrentParam    : IDPtr;
  384.     stay        : Boolean;
  385.     argtype        : TypePtr;
  386.     argindex        : integer;
  387.     totalsize        : integer;
  388.     lab            : integer;
  389.     Expr        : ExprPtr;
  390.     Argument        : ExprPtr;
  391.     NextExpr        : ExprPtr;
  392. begin
  393.     Stay := True;
  394.     Expr := MakeNode(func1, Nil, Nil, ID^.VType, Integer(ID));
  395.     NextExpr := Nil;
  396.     if Match(LeftParent1) then begin
  397.     CurrentParam := ID^.Param;
  398.     while (not Match(RightParent1)) and Stay do begin
  399.         if CurrentParam = Nil then
  400.         ReadParameters := BuildError("Argument not expected");
  401.         if CurrentParam^.Object = valarg then begin
  402.         Argument := ExpressionTree;
  403.         if not TypeCheck(Argument^.EType, CurrentParam^.VType) then begin
  404.             Mismatch;
  405.             Argument := MakeConstant(1,BadType);
  406.         end else begin
  407.             if NumberType(Argument^.EType) then begin
  408.             if (Argument^.EType = RealType) and
  409.                (CurrentParam^.VType^.Object = ob_ordinal) then
  410.                 Argument := MakeNode(Real2Int,
  411.                         PromoteTypeA(Argument, IntType),
  412.                         Nil,
  413.                         CurrentParam^.VType,0)
  414.             else
  415.                 Argument := PromoteTypeA(Argument, CurrentParam^.VType);
  416.             end;
  417.         end;
  418.         end else if CurrentParam^.Object = refarg then begin
  419.         Argument := GetReference;
  420.         if not TypeCmp(Argument^.EType, CurrentParam^.VType) then
  421.             Mismatch;
  422.         end;
  423.         if NextExpr = Nil then
  424.         Expr^.Left := Argument
  425.         else
  426.         NextExpr^.Next := Argument;
  427.         NextExpr := Argument;
  428.         CurrentParam := CurrentParam^.Next;
  429.         if CurrentParam <> Nil then
  430.         if not Match(Comma1) then
  431.             Error("Expected ,");
  432.     end;
  433.     if CurrentParam <> Nil then
  434.         error("More Parameters Expected");
  435.     end else begin
  436.     if ID^.Param <> Nil then
  437.         error("Expecting Some Parameters");
  438.     end;
  439.     ReadParameters := Expr;
  440. end;
  441.  
  442. {
  443.    This function reads an identifier and makes an appropriate
  444.    node.  The identifier can be a variable, function, constant,
  445.    or standard function.
  446. }
  447.  
  448. Function ReadIdentifier : ExprPtr;
  449. var
  450.     Expr : ExprPtr;
  451.     NextExpr : ExprPtr;
  452.     ID    : IDPtr;
  453. begin
  454.     ID := FindWithField(SymText);
  455.     if ID = Nil then
  456.     ID := FindID(SymText);
  457.     NextSymbol;
  458.     if ID = Nil then begin
  459.     ID := EnterStandard(SymText, global, BadType, st_none, 1);
  460.     { ReadBadArgs(ID); }
  461.     ReadIdentifier := BuildError("Unknown ID");
  462.     end;
  463.     case ID^.Object of
  464.       obtype : begin
  465.            NeedLeftParent;
  466.            Expr := MakeBinary(Type1, ExpressionTree, Nil, ID^.VType);
  467.            NeedRightParent;
  468.            end;
  469.       constant : Expr := MakeConstant(ID^.Offset, ID^.VType);
  470.       global,
  471.       local,
  472.       refarg,
  473.       valarg   : Expr := MakeNode(Var1, Nil, Nil, ID^.VType, Integer(ID));
  474.       typed_const : if ConstantExpression then
  475.             Expr := MakeConstant(ID^.Offset, ID^.VType)
  476.             else
  477.             Expr := MakeNode(Var1, Nil, Nil, ID^.VType, Integer(ID));
  478.       func     : Expr := ReadParameters(ID);
  479.       stanfunc : Expr := GetStandardFunction(ID);
  480.       field    : Expr := MakeNode(Field1,ExprPtr(LastWith),Nil,ID^.VType,Integer(ID));
  481.     else
  482.     Expr := BuildError("Expecting a variable or function reference");
  483.     end;
  484.     ReadIdentifier := Expr;
  485. end;
  486.  
  487. Function Primary : ExprPtr;
  488. var
  489.     Expr    : ExprPtr;
  490.     TP,TP2  : TypePtr;
  491.     LitSpot : Integer;
  492. begin
  493.     case CurrSym of
  494.       numeral1 : begin
  495.             if Abs(SymLoc) > 32767 then
  496.             Expr := MakeConstant(SymLoc, IntType)
  497.             else if (SymLoc > 255) or (SymLoc < 0) then
  498.             Expr := MakeConstant(SymLoc, ShortType)
  499.             else
  500.             Expr := MakeConstant(SymLoc, ByteType);
  501.                     NextSymbol;
  502.                 end;
  503.       realnumeral1:
  504.         begin
  505.             Expr := MakeConstant(Integer(RealValue), RealType);
  506.                     NextSymbol;
  507.                 end;
  508.       minus1  : begin
  509.             NextSymbol;
  510.             Expr := Factor;
  511.             if not NumberType(Expr^.EType) then
  512.             Expr := BuildError("Expecting a numeric type")
  513.             else
  514.             Expr := MakeNode(minus1, Expr, Nil, Expr^.EType, 0);
  515.         end;
  516.       plus1   : begin
  517.             NextSymbol;
  518.             Expr := Factor;
  519.             if not NumberType(Expr^.EType) then
  520.             Expr := BuildError("Expecting a numeric type");
  521.         end;
  522.       at1 :     begin
  523.             NextSymbol;
  524.             Expr := MakeNode(at1, GetReference, Nil, AddressType, 0);
  525.         end;
  526.       not1    : begin
  527.             NextSymbol;
  528.             Expr := Factor;
  529.             if Expr^.EType^.Object <> ob_ordinal then
  530.             Expr := BuildError("Expecting an ordinal type")
  531.             else
  532.             Expr := MakeNode(not1, Expr, Nil, Expr^.EType, 0);
  533.         end;
  534.       ident1  : Expr := ReadIdentifier;
  535.       leftparent1 :
  536.         begin
  537.             NextSymbol;
  538.             Expr := ExpressionTree;
  539.             NeedRightParent;
  540.         end;
  541.       Apostrophe1 :
  542.         begin
  543.             LitSpot := LitPtr;
  544.             TP := ReadLitA(Chr(39));
  545.             if TP^.Upper = 1 then begin
  546.             Dec(LitPtr);
  547.             Expr := MakeConstant(Ord(LitQ[LitPtr]), CharType);
  548.             end else begin
  549.             New(TP2);  { Add new type for array }
  550.             TP2^ := TP^;
  551.             TP2^.Next := CurrentBlock^.FirstType;
  552.             CurrentBlock^.FirstType := TP2;
  553.             Expr := MakeNode(quote1, Nil, Nil, TP2, LitSpot);
  554.             end;
  555.         end;
  556.       Quote1 :  begin
  557.             LitSpot := LitPtr;
  558.             TP := ReadLitA('"');
  559.             Expr := MakeNode(quote1, Nil, Nil, TP, LitSpot);
  560.         end;
  561.     else
  562.         Expr := BuildError("Unknown Factor");
  563.     end;
  564.     Primary := Expr;
  565. end;
  566.  
  567. Function MakeFieldRef(Expr : ExprPtr; Offset : Integer; TP : TypePtr) : ExprPtr;
  568. begin
  569.     if Expr^.Kind = period1 then begin
  570.         Expr^.Value := Expr^.Value + Offset;
  571.         Expr^.EType := TP;
  572.         MakeFieldRef := Expr;
  573.     end;
  574.     MakeFieldRef := MakeNode(Period1, Expr, Nil, TP, Offset);
  575. end;
  576.  
  577. Function MakeIndirection(Expr : ExprPtr) : ExprPtr;
  578. var
  579.     Result : ExprPtr;
  580. begin
  581.     MakeIndirection := MakeNode(Carat1, Expr, Nil, Expr^.EType^.SubType, 0);
  582. end;
  583.  
  584. Function MakeIndex(L, R : ExprPtr; TP : TypePtr) : ExprPtr;
  585. var
  586.     Result : ExprPtr;
  587. begin
  588.  
  589. {
  590.     These first statements create the following structure:
  591.  
  592.         *
  593.            / \
  594.      element  -
  595.       size   /  \
  596.           promote\
  597.            /      lower bound
  598.          index
  599.        expression
  600.  
  601.     Which is the general calculation for array addressing:
  602.     base address + (index - lower bound) * element size
  603.  
  604.     L := The expression for the array address
  605.     R := The expression for the index
  606. }
  607.  
  608.     case R^.EType^.Size of
  609.       1 : R^.EType := ByteType;
  610.       2 : R^.EType := ShortType;
  611.       4 : R^.EType := IntType;
  612.     end;
  613.  
  614.     with L^.EType^ do begin
  615.     if Lower <> 0 then
  616.         R := MakeBinary(minus1,MakeConstant(Lower,R^.EType),
  617.                 R, R^.EType);
  618.     if (Upper > MaxShort) or (SubType^.Size > MaxShort) then begin
  619.         R := MakeBinary(asterisk1,
  620.             MakeConstant(SubType^.Size,IntType),
  621.             PromoteTypeA(R,IntType),
  622.             IntType)
  623.     end else begin
  624.         R := MakeBinary(asterisk1,
  625.             MakeConstant(SubType^.Size,ShortType),
  626.             PromoteTypeA(R,ShortType),IntType);
  627.     end;
  628.     end;
  629.     MakeIndex := MakeNode(LeftBrack1, L, R, TP, 0);
  630. end;
  631.  
  632. Function GetReference : ExprPtr;
  633. var
  634.     Left,
  635.     Right  : ExprPtr;
  636.     Leave  : Boolean;
  637.     TP     : TypePtr;
  638.     ID     : IDPtr;
  639. begin
  640.     ID := FindWithField(SymText);
  641.     if ID = Nil then
  642.     ID := FindID(SymText);
  643.     NextSymbol;
  644.  
  645.     if ID = Nil then begin
  646.     ID := EnterStandard(SymText, global, BadType, st_none, 1);
  647.     { ReadBadArgs(ID); }
  648.     GetReference := BuildError("Unknown ID");
  649.     end;
  650.  
  651.     case ID^.Object of
  652.       obtype : begin
  653.            NeedLeftParent;
  654.            Left := MakeNode(type1, GetReference, Nil, ID^.VType, 0);
  655.            NeedRightParent;
  656.            end;
  657.       global,
  658.       local,
  659.       refarg,
  660.       typed_const,
  661.       valarg,
  662.       proc,
  663.       func    : Left := MakeNode(Var1, Nil, Nil, ID^.VType, Integer(ID));
  664.       field    : Left := MakeNode(Field1, ExprPtr(LastWith), Nil, ID^.VType, Integer(ID));
  665.     else
  666.     GetReference := BuildError("Expecting an identifier");
  667.     end;
  668.  
  669.     Leave := False;
  670.     repeat
  671.         case CurrSym of { handle ., [, and '^' here }
  672.           period1 : begin
  673.             NextSymbol;
  674.             if Left^.EType^.Object = ob_record then begin
  675.                 if CurrSym = ident1 then begin
  676.                 ID := FindField(SymText, Left^.EType);
  677.                 if ID <> Nil then
  678.                     Left := MakeFieldRef(Left, ID^.Offset, ID^.VType)
  679.                 else
  680.                     Left := BuildError("Unknown Field");
  681.                 NextSymbol;
  682.                 end else
  683.                 Left := BuildError("Expecting an identifier");
  684.             end else
  685.                 Left := BuildError("Not a Record Type");
  686.                     end;
  687.           carat1 :  begin
  688.             NextSymbol;
  689.             if (Left^.EType^.Object <> ob_pointer) and
  690.                (Left^.EType^.Object <> ob_file) then
  691.                 Left := BuildError("Expecting a pointer or file for ^")
  692.             else
  693.                 Left := MakeIndirection(Left)
  694.             end;
  695.           leftbrack1 :
  696.             begin
  697.             NextSymbol;
  698.             repeat
  699.                 if Left^.EType^.Object = ob_array then begin
  700.                 Right := ExpressionTree;
  701.                 if not TypeCheck(Right^.EType, Left^.EType^.Ref) then
  702.                     MisMatch;
  703.                 if Right^.Kind = Const1 then begin
  704.                     if RangeCheck then begin
  705.                     if (Right^.Value > Left^.EType^.Upper) or
  706.                        (Right^.Value < Left^.EType^.Lower) then
  707.                         Error("Index out of range");
  708.                     end;
  709.                     Left := MakeFieldRef(Left,
  710.                        (Right^.Value - Left^.EType^.Lower) *
  711.                         Left^.EType^.SubType^.Size,
  712.                         Left^.EType^.SubType)
  713.                 end else
  714.                     Left := MakeIndex(Left,Right,Left^.EType^.SubType);
  715.                 end else if Left^.EType = StringType then begin
  716.                 Right := ExpressionTree;
  717.                 if TypeCheck(Right^.EType, IntType) then
  718.                     Left := MakeIndex(Left,Right,CharType)
  719.                 else
  720.                     Left := BuildError("Expecting an integer index");
  721.                 end else
  722.                 Left := BuildError("Not an Array Type");
  723.             until not Match(Comma1);
  724.             if not Match(RightBrack1) then
  725.                 Error("Expecting ]");
  726.             end;
  727.         else
  728.             Leave := True;
  729.         end;
  730.     until Leave;
  731.     GetReference := Left;
  732. end;
  733.  
  734. { Create a factor tree.  This level handles the seperators, which in
  735.   version 1.2 are now considered operators. }
  736.  
  737. Function Factor : ExprPtr;
  738. var
  739.     Left,
  740.     Right  : ExprPtr;
  741.     Leave  : Boolean;
  742.     TP     : TypePtr;
  743.     ID     : IDPtr;
  744. begin
  745.     Left := Primary;
  746.     Leave := False;
  747.     repeat
  748.         case CurrSym of { handle ., [, and '^' here }
  749.           period1 : begin
  750.             NextSymbol;
  751.             if Left^.EType^.Object = ob_record then begin
  752.                 if CurrSym = ident1 then begin
  753.                 ID := FindField(SymText, Left^.EType);
  754.                 if ID <> Nil then
  755.                     Left := MakeFieldRef(Left, ID^.Offset, ID^.VType)
  756.                 else
  757.                     Left := BuildError("Unknown Field");
  758.                 NextSymbol;
  759.                 end else
  760.                 Left := BuildError("Expecting an identifier");
  761.             end else
  762.                 Left := BuildError("Not a Record Type");
  763.                     end;
  764.           carat1 :  begin
  765.             NextSymbol;
  766.             if (Left^.EType^.Object <> ob_pointer) and
  767.                (Left^.EType^.Object <> ob_file) then
  768.                 Left := BuildError("Expecting a pointer or file type")
  769.             else
  770.                 Left := MakeIndirection(Left)
  771.             end;
  772.           leftbrack1 :
  773.             begin
  774.             NextSymbol;
  775.             repeat
  776.                 if Left^.EType^.Object = ob_array then begin
  777.                 Right := ExpressionTree;
  778.                 if not TypeCheck(Right^.EType, Left^.EType^.Ref) then
  779.                     MisMatch;
  780.                 if Right^.Kind = Const1 then
  781.                     Left := MakeFieldRef(Left,
  782.                         (Right^.Value - Left^.EType^.Lower) *
  783.                          Left^.EType^.SubType^.Size,
  784.                          Left^.EType^.SubType)
  785.                 else
  786.                     Left := MakeIndex(Left,Right,Left^.EType^.SubType);
  787.                 end else if Left^.EType = StringType then begin
  788.                 Right := ExpressionTree;
  789.                 if TypeCheck(Right^.EType, IntType) then
  790.                     Left := MakeIndex(Left,Right,CharType)
  791.                 else
  792.                     Left := BuildError("Expecting an integer index");
  793.                 end else
  794.                 Left := BuildError("Not an Array Type");
  795.             until not Match(Comma1);
  796.             if not Match(RightBrack1) then
  797.                 Error("Expecting ]");
  798.                     end;
  799.         else
  800.             Leave := True;
  801.         end;
  802.     until Leave;
  803.     Factor := Left;
  804. end;
  805.  
  806. { Create a term tree.  This routine handles multiplication, division,
  807.   and, shl, shr, and mod }
  808.  
  809. Function Term : ExprPtr;
  810. var
  811.     Left,
  812.     Right    : ExprPtr;
  813.     Leave    : Boolean;
  814.     Op       : Symbols;
  815. begin
  816.     Left := Factor;
  817.     Leave := False;
  818.     repeat
  819.         case CurrSym of
  820.           asterisk1:
  821.         begin
  822.             CheckNumeric(Left);
  823.             NextSymbol;
  824.             Right := Factor;
  825.             CheckNumeric(Right);
  826.             CheckType(Left,Right);
  827.             Left  := PromoteTypeA(Left, ShortType); { at least }
  828.             Left  := PromoteTypeA(Left, Right^.EType);
  829.             Right := PromoteTypeA(Right, Left^.EType);
  830.             if Left^.EType^.Size < 4 then
  831.             Left  := MakeCommutativeBinary(asterisk1, Left, Right, IntType)
  832.             else
  833.             Left := MakeBinary(asterisk1, Left, Right, Left^.EType);
  834.         end;
  835.           realdiv1 :
  836.         begin
  837.             CheckNumeric(Left);
  838.             NextSymbol;
  839.             Right := Factor;
  840.             CheckNumeric(Right);
  841.             CheckType(Left,Right);
  842.             Left  := PromoteTypeA(Left, RealType);
  843.             Right := PromoteTypeA(Right, Left^.EType);
  844.             Left := MakeBinary(realdiv1, Right, Left, RealType);
  845.         end;
  846.       div1,
  847.       mod1: begin
  848.             Op := CurrSym;
  849.             CheckNumeric(Left);
  850.             NextSymbol;
  851.             Right := Factor;
  852.             CheckNumeric(Right);
  853.             CheckType(Left,Right);
  854.             Left := AutoInt(Left);
  855.             Right := AutoInt(Right);
  856.             Left  := PromoteTypeA(Left, IntType);
  857.             Right := PromoteTypeA(Right, ShortType);
  858.             Left := MakeBinary(Op, Right, Left, Right^.EType);
  859.         end;
  860.       and1,
  861.       shl1,
  862.       shr1: begin
  863.             Op := CurrSym;
  864.             if Left^.EType = RealType then
  865.             Left := AutoInt(Left)
  866.             else
  867.             CheckOrdinal(Left);
  868.             NextSymbol;
  869.             Right := Factor;
  870.             if Right^.EType = RealType then
  871.             Right := AutoInt(Right)
  872.             else
  873.             CheckOrdinal(Right);
  874.             CheckType(Left,Right);
  875.             if NumberType(Left^.EType) then begin
  876.             Left  := PromoteTypeA(Left, Right^.EType);
  877.             Right := PromoteTypeA(Right, Left^.EType);
  878.             if Op <> and1 then
  879.                 Left := PromoteTypeA(Left, IntType);
  880.             end;
  881.             if (Op = And1) and
  882.                ((Left^.EType <> BoolType) or (not ShortCircuit)) then
  883.             Left := MakeCommutativeBinary(Op, Left, Right, Left^.EType)
  884.             else
  885.             Left := MakeBinary(Op, Left, Right, Left^.EType);
  886.         end;
  887.         else
  888.             Leave := True;
  889.         end;
  890.     until Leave;
  891.     Term := Left;
  892. end;
  893.  
  894. { Create simple expression tree.  This routine handles +, -, or, and xor }
  895.  
  896. Function Simple : ExprPtr;
  897. var
  898.     Left,
  899.     Right   : ExprPtr;
  900.     Leave   : Boolean;
  901.     Op      : Symbols;
  902. begin
  903.     Left := Term;
  904.     Leave := False;
  905.     repeat
  906.         case CurrSym of
  907.           plus1,
  908.           minus1 : begin
  909.                       Op := CurrSym;
  910.                       CheckNumeric(Left);
  911.                       NextSymbol;
  912.                       Right := Term;
  913.                       CheckNumeric(Right);
  914.                       CheckType(Left,Right);
  915.                       Left  := PromoteTypeA(Left, Right^.EType);
  916.                       Right := PromoteTypeA(Right, Left^.EType);
  917.                       if Op = plus1 then
  918.                           Left := MakeCommutativeBinary(Op, Left, Right, Left^.EType)
  919.                       else
  920.                           Left := MakeBinary(Op, Right, Left, Left^.EType);
  921.                   end;
  922.       or1,
  923.       xor1: begin
  924.             Op := CurrSym;
  925.             if Left^.EType = RealType then
  926.             Left := AutoInt(Left)
  927.             else
  928.             CheckOrdinal(Left);
  929.             NextSymbol;
  930.             Right := Term;
  931.             if Right^.EType = RealType then
  932.             Right := AutoInt(Right)
  933.             else
  934.             CheckOrdinal(Right);
  935.             CheckType(Left,Right);
  936.             if NumberType(Left^.EType) then begin
  937.             Left  := PromoteTypeA(Left, Right^.EType);
  938.             Right := PromoteTypeA(Right, Left^.EType);
  939.             end;
  940.             if (not ShortCircuit) or (Op <> or1) or
  941.                 (Left^.EType <> BoolType) then
  942.             Left := MakeCommutativeBinary(Op, Left, Right, Left^.EType)
  943.             else
  944.             Left := MakeBinary(Op, Left, Right, Left^.EType);
  945.         end;
  946.         else
  947.             Leave := True;
  948.         end;
  949.     until Leave;
  950.     Simple := Left;
  951. end;
  952.  
  953. { Create an expression tree.  This routine calls the others, and
  954.   handles comparison operators, which have the lowest precedence. }
  955.  
  956. Function ExpressionTree : ExprPtr;
  957. var
  958.     Left,
  959.     Right  : ExprPtr;
  960.     Leave  : Boolean;
  961.     Op     : Symbols;
  962. begin
  963.     Left  := Simple;
  964.     Leave := False;
  965.     repeat
  966.         case CurrSym of
  967.           less1,
  968.           greater1,
  969.           notless1,
  970.           notgreater1 : begin
  971.                             Op := CurrSym;
  972.                 if Left^.EType <> RealType then
  973.                 CheckOrdinal(Left);
  974.                             NextSymbol;
  975.                             Right := Simple;
  976.                 if Right^.EType <> RealType then
  977.                 CheckOrdinal(Right);
  978.                             CheckType(Left, Right);
  979.                 if NumberType(Left^.EType) then begin
  980.                 if Left^.EType = ByteType then
  981.                     Left := PromoteTypeA(Left, ShortType);
  982.                 Left  := PromoteTypeA(Left, Right^.EType);
  983.                 Right := PromoteTypeA(Right, Left^.EType);
  984.                 end;
  985.                             Left := MakeBinary(Op, Left, Right, BoolType);
  986.                         end;
  987.           equal1,
  988.           notequal1   : begin
  989.                             Op := CurrSym;
  990.                             NextSymbol;
  991.                             Right := Simple;
  992.                             CheckType(Left, Right);
  993.                 if NumberType(Left^.EType) then begin
  994.                 Left := PromoteTypeA(Left, Right^.EType);
  995.                 Right := PromoteTypeA(Right, Left^.EType);
  996.                 end;
  997.                             Left := MakeCommutativeBinary(Op, Left, Right, BoolType);
  998.                         end;
  999.         else
  1000.             Leave := True;
  1001.         end;
  1002.     until Leave;
  1003.     ExpressionTree := Left;
  1004. end;
  1005.